home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
BMUG Revelations
/
BMUG Revelations.toast
/
Programming
/
Programming Languages
/
Yerk 3.64
/
tool+
/
popupctl
next >
Wrap
Text File
|
1993-06-23
|
3KB
|
96 lines
\ 5/26/93 rfl System 7 support for PopUpMenus...doesn't work for <7.
\ See popUpMenu6 for <7 support.
:CLASS popUpMenu <super Control 4 <indexed
rect bounds
int valueParm
:M handle: ptr: ctlhndl 28 + @ -base @ -base @ ;M
:M putRect: put: bounds ;M
\ *** next three methods apply to the Title box, not the popup ***
\ 0=left;1=center;255=right
:M justify: ( n --) get: valueParm $ ff00 and or put: valueParm ;M
\ $100=bold;$200=italic;$400=underline;$800=outline;$1000=shadow
:M face: ( n --) get: valueParm $ e0ff and or put: valueParm ;M
\ $2000=condense;$4000=extend;$8000=nostyle
:M style: ( n --) get: valueParm $ 1fff and or put: valueParm ;M
\ build a popup; procid is set to 1=fixedwidth;4=addresmen;8=useWFont
:M NEW: { x y addr len theWind \ tWid -- }
theWind saveFont
get: procID 8 and 0=
IF 0 tFont 12 tSize THEN addr len tWidth -> tWid \ width of title
0 abs: theWind Abs: bounds addr len str255
w 256 int: valueParm int: resId twid makeint 1008 get: procId +
makeInt ^base
call NewControl put: ctlhndl
^base get: ctlhndl set-ctl-obj
theWind put: myWindow theWind restFont ;M
\ :M getnew: { \ theWind -- } get: myWindow -> theWind
\ theWind 0= classerr" 157 theWind saveFont
\ 0 int: resID theWind +base call getNewControl dup 0= classerr" 170
\ put: ctlhndl
\ ^base get: ctlhndl set-ctl-obj
\ theWind put: myWindow get: myValue put: self theWind restFont ;M
:M size: handle: self >ptr 22 + w@ ;M
\ ( cfa0...cfaN resid -- ) put resid and handlers in menu
:M PUT: Put: ResId Put: Super ;M
:M PUTITEM: { theVal -- } alive: [ obj: myWindow ]
IF theVal put: super THEN
theVal put: myValue ;M
:M GETITEM: ( -- item) alive: [ obj: myWindow ]
IF get: super dup put: myValue ELSE get: myValue THEN ;M
:M EXEC: ( part# --)
IF getItem: self -> mitem
^base -> theMenu get: resID -> menuID
mitem 1- at: self execute exec: action
THEN ;M
\ ( item# -- addr len ) get string for item #
:M GET: ( item -- addr len ) handle: self swap makeInt
buf255 +base call GetItem buf255 count ;M
:M GETNAME: ( -- addr len) handle: self >ptr 14 + count ;M
\ ( addr len -- ) Append a menu item
:M ADD: Str255 handle: self ?new swap call AppendMenu ;M
\ ( addr len item# -- ) replace menu item string
:M SET: >r str255 >r handle: self ?new
r> r> swap >r makeInt r> call SetItem draw: [ obj: myWindow ] ;M
\ ( item# -- ) Enable a menu item
:M ENABLE: handle: self swap makeInt call EnableItem draw: [ obj: myWindow ] ;M
\ ( item# -- ) Grey and disable an item
:M DISABLE: handle: self swap makeInt call DisableItem draw: [ obj: myWindow ] ;M
:M CHECKED?: ( item -- b) get: super = ;M
;CLASS
\ Example:
\ ctlwind suz
\ example: suz setlimits: suz
\ " .rsrc" openresfile
\
\ 5 popupmenu bob
\ 100 50 300 69 putrect: bob
\ 128 putresid: bob
\ 100 50 " " suz new: bob
\
\ : one mitem home . ;
\ 'c one fill: bob